Personal Computer World 2009 February/PCWFEB09.iso/Software/Linux/Kubuntu 8.10/kubuntu-8.10-desktop-i386.iso/casper/filesystem.squashfs/usr/share/defoma/scripts/fontconfig.defoma

Text File | 2008-09-18 | 5KB | 241 lines

# -*- perl -*-
# Defoma configuration script for fontconfig
# Copyright © 2003 Angus Lees <[e-mail]>
# This file is hereby placed into the public domain.

@ACCEPT_CATEGORIES = qw(type1 truetype cid);
# .. and any other categories supported by freetype

package fontconfig;

use Debian::Defoma::Common;
use Debian::Defoma::Id;
use Debian::Defoma::Subst;

use strict;
use warnings;

my $PkgDir = "$ROOTDIR/fontconfig.d";
my ($Id, $Sb);

my %UpdatedDirectories = ();

sub init {
  $Id ||= defoma_id_open_cache() or return 1;
  $Sb ||= defoma_subst_open(rulename => 'fontconfig',
                threshold => 70,
                idobject => $Id) or return 1;

  return 0;
}

sub register {
  my $font = shift;
  my $hints = parse_hints_start(@_);

  return 1 unless $hints->{FontName};

  my $priority = $hints->{Priority} || 20;
  my ($fontname) = split / +/, $hints->{FontName};
  my @alias = split / +/, $hints->{Alias} if $hints->{Alias};

  defoma_id_register($Id, type => 'real', font => $font,
             id => $fontname, priority => $priority,
             hints => join(' ', @_));

  foreach my $alias (@alias) {
    defoma_id_register($Id, type => 'alias', font => $font,
               id => $alias, priority => $priority,
               origin => $fontname);
  }

  defoma_subst_register($Sb, $font, $fontname);

  return 0;
}

sub unregister {
  my $font = shift;
  defoma_subst_unregister($Sb, $font);
  defoma_id_unregister($Id, type => 'alias', font => $font);
  defoma_id_unregister($Id, type => 'real', font => $font);
  return 0;
}

sub dirname {
   my $path = shift;

   $path =~ s/\/[^\/]*$//;
   return $path;
}

sub do_install_real {
  my $font = shift;
  my $id = shift;

  my $dir = dirname ($font);
  $UpdatedDirectories{$dir} = 1;
  return 0;
}

sub do_remove_real {
  my $font = shift;
  my $id = shift;

  my $dir = dirname ($font);
  $UpdatedDirectories{$dir} = 1;

  return 0;
}

sub fontconfig_dirs {
   my %dirs = ();

   system ('fc-cache', '-s');
   open my $file, "fc-list : file |" or return ();
   while (<$file>) {
       my $dir = dirname ($_);
    if (!exists $dirs{$dir}) {
        $dirs{$dir} = 1;
    }
    }
    close $file;
    return %dirs;
}

#
# Clean up from old fontconfig defoma mechanism which
# placed symlinks to each fontfile in the fontconfig.d directory
#
sub clean_oldstyle_dirs {
   opendir (DIR, $PkgDir) or return 1;
   my @dirs = grep { /^[^.]/ && -d "$PkgDir/$_" } readdir (DIR);
   closedir DIR;
   foreach my $dir (@dirs) {
       my $subdir = "$PkgDir/$dir";
       if (opendir (DIR, $subdir)) {
      my @files = grep { /^[^.]/ && -l "$subdir/$_" } readdir (DIR);
      closedir DIR;
      foreach my $file (@files) {
         if ( -l "$subdir/$file" ) {
             unlink "$subdir/$file";
         }
      }
      rmdir $subdir;
       }
   }
}

sub term {
  return unless $Id;

  -e "/etc/fonts/fonts.conf" or return 0;

  clean_oldstyle_dirs ();
  #
  # Update modified directories
  #

  my @dirs = keys (%UpdatedDirectories);
  if (@dirs) {
      print "Updating fontconfig cache for @dirs\n";
      system ("fc-cache", "-f", @dirs);
      #
      # make sure caches leading to new directories are updated
      #
      system ("fc-cache", "-s");
  }

  # Empty our config file to see
  # which directories are reachable without it

  open my $smash_fh, '>', "$PkgDir/fonts.conf" or return 1;
  print $smash_fh <<EOF;
<?xml version="1.0"?>
<!DOCTYPE fontconfig SYSTEM "/etc/fonts/fonts.dtd">
<!-- autogenerated by fontconfig.defoma -->
<fontconfig>
</fontconfig>
EOF
  close $smash_fh;
  my %dirs = fontconfig_dirs ();

  open my $fh, '>', "$PkgDir/fonts.conf" or return 1;

  print $fh <<EOF;
<?xml version="1.0"?>
<!DOCTYPE fontconfig SYSTEM "/etc/fonts/fonts.dtd">
<!-- autogenerated by fontconfig.defoma -->
<fontconfig>
EOF

  # directories
  my %newdirs = ();

  foreach (defoma_id_get_font($Id, installed => type => 'SrI')) {
    my $dir = dirname($Id->{e_font}->[$_]);
    if (!exists $dirs{$dir} && !exists $newdirs{$dir}) {
       print $fh "   <dir>$dir</dir>\n";
       $newdirs{$dir} = 1;
    }
  }

  # aliases
  foreach (defoma_id_get_font($Id, installed => type => 'SaI')) {
    print $fh <<EOF
   <alias>
      <family>$Id->{e_id}->[$_]</family>
      <accept><family>$Id->{e_depid}->[$_]</family></accept>
   </alias>
EOF
  }

  # substituded fonts
  foreach (defoma_id_get_font($Id, installed => type => 'SSI')) {
    print $fh <<EOF
   <alias>
      <family>$Id->{e_id}->[$_]</family>
      <default><family>$Id->{e_depid}->[$_]</family></default>
   </alias>
EOF
  }

  print $fh "</fontconfig>\n";

  close $fh;

  defoma_subst_close($Sb);
  defoma_id_close_cache($Id);

  system ("fc-cache", "-s");
  return 0;
}

sub main {
  my $cmd = shift;

  if ($cmd eq 'init') {
    init();
  } elsif ($cmd eq 'register') {
    return register(@_);
  } elsif ($cmd eq 'unregister') {
    return unregister(@_);
  } elsif ($cmd eq 'do-install-real') {
    return do_install_real(@_);
  } elsif ($cmd eq 'do-remove-real') {
    return do_remove_real(@_);
  } elsif ($cmd eq 'term') {
    return term(@_);
  }

  0;
}

no warnings;

*truetype  = \&main;
*type1       = \&main;
*cid       = \&main;

1;